home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / error.tcl.z / error.tcl
Text File  |  2002-07-08  |  7KB  |  249 lines
  1. # error.tcl
  2. #
  3. # tkerror for exmh
  4. #
  5. # Copyright (c) 1993 Xerox Corporation.
  6. # Use and copying of this software and preparation of derivative works based
  7. # upon this software are permitted. Any distribution of this software or
  8. # derivative works must comply with all applicable United States export
  9. # control laws. This software is made available AS IS, and Xerox Corporation
  10. # makes no warranty about the software, its performance or its conformity to
  11. # any specification.
  12.  
  13. #
  14. # tkerror --
  15. #    This is the handler for background errors that arise
  16. #    from commands bound to keystrokes and menus.  A
  17. #    toplevel message widget is used to display $errorInfo
  18.  
  19. set ErrorIgnore {
  20.     {^grab failed}
  21. }
  22.  
  23. proc tkerror { msg } {
  24.     global errorInfo exmh ErrorIgnore
  25.  
  26.     foreach pat $ErrorIgnore {
  27.     if [regexp $pat $msg] {
  28.         Exmh_Status $msg
  29.         return
  30.     }
  31.     }
  32.     set font fixed
  33.     set base ".errorInfo"
  34.     set title "Error Info"
  35.     if [info exists errorInfo] {
  36.     set savedErrorInfo $errorInfo
  37.     } else {
  38.     set savedErrorInfo {no errorInfo}
  39.     }
  40.     # Create a toplevel to contain the error trace back
  41.     if [catch {
  42.     # Choose a unique name
  43.     for {set x 1} {$x<10} {set x [expr $x+1]} {
  44.         if {! [winfo exists $base-$x]} {
  45.         break
  46.         }
  47.     }
  48.     set title $title-$x
  49.     set name $base-$x
  50.  
  51.     set wx [expr ($x%20)*10]
  52.     Widget_Toplevel $name Error $wx $wx
  53.  
  54.     wm title $name $title
  55.     wm iconname $name $title
  56.     wm minsize $name 20 5
  57.     
  58.     frame $name.buttons
  59.     pack $name.buttons -side top -fill x
  60.     
  61.     button $name.buttons.quit -text "Dismiss" -command [list destroy $name]
  62.     pack append $name.buttons $name.buttons.quit {left}
  63.     if [info exists exmh(maintainer)] {
  64.         button $name.buttons.mailto -text "Mail to $exmh(maintainer)" -command [list ExmhMailError $name $errorInfo]
  65.         pack append $name.buttons $name.buttons.mailto {right}
  66.     }
  67.     global widgetText TextType
  68.  
  69.     message $name.ex -font $font -aspect 1000 -text \
  70. "Please type a few words of explanation before
  71. pressing the Mail to button, or just Dismiss me."
  72.     pack $name.ex -side top -fill x
  73.     text $name.user -font $font -width 60 -bd 2 -relief raised
  74.     $name.user configure -height 5
  75.     $name.user insert end "What happened: "
  76.     $name.user tag add sel 1.0 1.14
  77.     focus $name.user
  78.     pack $name.user -side top -fill both -expand true
  79.     $name.user mark set hlimit 1.0
  80.     set widgetText($name.user,extend) 0
  81.     set widgetText($name.user,geo) {}
  82.     set TextType($name.user) text
  83.  
  84.     frame $name.msg
  85.     pack $name.msg -side top -fill both -expand true
  86.  
  87.     text $name.msg.t -font $font -width 60 -bd 2 -relief raised \
  88.         -setgrid true -yscrollcommand [list $name.msg.sy set]
  89.     scrollbar $name.msg.sy -orient vertical -command [list $name.msg.t yview]
  90.     set numLines [llength [split $errorInfo \n]]
  91.     if {$numLines > 20} {
  92.         set numLines 20
  93.     }
  94.     $name.msg.t configure -height $numLines
  95.     $name.msg.t insert end $errorInfo
  96.     pack $name.msg.sy -side right -fill y
  97.     pack $name.msg.t -side left -fill both -expand true
  98.     set widgetText($name.msg.t,extend) 0
  99.     set widgetText($name.msg.t,geo) {}
  100.     set TextType($name.msg.t) text
  101.  
  102.     Visibility_Wait $name
  103.  
  104.     } oops] {
  105.     set msg [concat $msg "($name: " $oops ")" ]
  106.    }
  107.  
  108.     if {[string length $msg] > 20} {
  109.     set msg [concat [string range $msg 0 30] ...]
  110.     }
  111.     if [catch {Exmh_Status "tkerror: $msg" purple}] {
  112.     puts stderr "tkrror: $msg"
  113.     puts stderr "*** TCL Trace ***"
  114.     puts stderr $savedErrorInfo
  115.     }
  116. }
  117. proc bgerror [info args tkerror] [info body tkerror]
  118.  
  119. proc ExmhMailError { w errInfo } {
  120.     global exmh
  121.     if [file exists [Env_Tmp]/exmhErrorMsg] {
  122.         file delete [Env_Tmp]/exmhErrorMsg
  123.     }
  124.     if [catch {open [Env_Tmp]/exmhErrorMsg w} out] {
  125.     Exmh_Status "Cannot open [Env_Tmp]/exmhErrorMsg" purple
  126.     return
  127.     }
  128.     if [catch {
  129.     global env tk_version tk_patchLevel tcl_version tcl_patchLevel
  130.     puts $out "To: $exmh(maintainer)"
  131.     puts $out "Subject: error exmh [lrange $exmh(version) 1 end]"
  132.     puts $out ""
  133.     set line [$w.user get 1.0 1.end]
  134.     if [regexp {^What happened:} $line] {
  135.         puts $out [string range $line 14 end]
  136.     } else {
  137.         puts $out $line
  138.     }
  139.     puts $out [$w.user get 2.0 end]
  140.     puts $out ""
  141.     puts $out "[exec date]"
  142.     if [info exists env(USER)] {
  143.         puts $out "$env(USER) got an error"
  144.     }
  145.     puts $out "Exmh $exmh(version)"
  146.     if [info exists tk_patchLevel] {
  147.         set v $tk_patchLevel
  148.     } else {
  149.         set v $tk_version
  150.     }
  151.     puts $out "TK version $v"
  152.     if [info exists tcl_patchLevel] {
  153.         set v $tcl_patchLevel
  154.     } else {
  155.         set v $tcl_version
  156.     }
  157.     puts $out "TCL version $v"
  158.     catch {exec uname -a} uname
  159.     puts $out "$uname"
  160.     puts $out ""
  161.     puts $out $errInfo
  162.     close $out
  163.     } msg] {
  164.     Exmh_Status "[Env_Tmp]/exmhErrorMsg $msg" purple
  165.     return
  166.     }
  167.     if [catch {
  168.     exec send [Env_Tmp]/exmhErrorMsg
  169.     } msg] {
  170.     Exmh_Status "Send error: $msg" purple
  171.     return
  172.     } else {
  173.     Exmh_Status "Mailed report to $exmh(maintainer)"
  174.     destroy $w
  175.     }
  176. }
  177.  
  178. proc Exmh_Error { msg } {
  179.     global errorInfo
  180.     set errorInfo {}
  181.     set level [info level]
  182.     for {set l 0} {$l <= $level} {incr l} {
  183.     append errorInfo [info level $l]
  184.     append errorInfo \n
  185.     }
  186.     tkerror $msg
  187. }
  188.  
  189. # Contributed by Jim Fulton
  190. proc Send_Error { msg draftID } {
  191.     global exmh
  192.  
  193.     set font fixed
  194.     set base ".errorSend"
  195.     set title "Address or Header Error"
  196.  
  197.     # Choose a unique name by testing for the associated error variable
  198.     # Use the string ".errorSend-N" as the name of the toplevel
  199.     # and as the name of a variable holding the current errorSend
  200.     for {set x 1} {$x<10} {set x [expr $x+1]} {
  201.     global $base-$x
  202.     if {! [info exists $base-$x]} {
  203.         break
  204.     }
  205.     }
  206.  
  207.     set title $title-$x
  208.     set name $base-$x
  209.     set $name $draftID
  210.  
  211.     set wx [expr ($x%20)*10]
  212.     Widget_Toplevel $name Error $wx $wx
  213.  
  214.     wm title $name $title
  215.     
  216.     frame $name.buttons
  217.     pack append $name $name.buttons {top fill expand}
  218.     
  219.     button $name.buttons.quit -text "Dismiss" -command "
  220.         destroy $name
  221.             unset $name
  222.         "            
  223.     pack append $name.buttons $name.buttons.quit {left}
  224.     button $name.buttons.edit -text "Re-edit draft" -command "
  225.         destroy $name
  226.             unset $name
  227.         Edit_DraftID $draftID
  228.     "
  229.     pack append $name.buttons $name.buttons.edit {right}
  230.  
  231.     button $name.buttons.retry -text "Retry Send" -command "
  232.         destroy $name
  233.             unset $name
  234.         Edit_Done send $draftID
  235.     "
  236.     pack append $name.buttons $name.buttons.retry {right}
  237.     global widgetText TextType
  238.  
  239.     text $name.msg -font $font -width 60 -bd 2 -relief raised
  240.     set numLines 10
  241.     $name.msg configure -height $numLines
  242.     $name.msg insert end $msg
  243.     pack append $name $name.msg {top expand}
  244.     set widgetText($name.msg,extend) 0
  245.     set widgetText($name.msg,geo) {}
  246.     set TextType($name.msg) text
  247. }
  248.  
  249.